home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / listing.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  8.4 KB  |  201 lines
  1. (herald (assembler listing t 1)
  2.         (env t (assembler as_open) 
  3.                (assembler fg) 
  4.                (assembler ib) 
  5.                (assembler mark)))
  6.  
  7. ;;; Copyright (c) 1985 Yale University
  8. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  9. ;;; This material was developed by the T Project at the Yale University Computer 
  10. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  11. ;;; and to use it for any purpose is granted, subject to the following restric-
  12. ;;; tions and understandings.
  13. ;;; 1. Any copy made of this software must include this copyright notice in full.
  14. ;;; 2. Users of this software agree to make their best efforts (a) to return
  15. ;;;    to the T Project at Yale any improvements or extensions that they make,
  16. ;;;    so that these may be included in future releases; and (b) to inform
  17. ;;;    the T Project of noteworthy uses of this software.
  18. ;;; 3. All materials developed as a consequence of the use of this software
  19. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  20. ;;;    of acknowledging credit in academic research.
  21. ;;; 4. Yale has made no warrantee or representation that the operation of
  22. ;;;    this software will be error-free, and Yale is under no obligation to
  23. ;;;    provide any services, by way of maintenance, update, or otherwise.
  24. ;;; 5. In conjunction with products arising from the use of this material,
  25. ;;;    there shall be no use of the name of the Yale University nor of any
  26. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  27. ;;;    without prior written consent from Yale in each case.
  28. ;;;
  29.  
  30. ;;; maybe for listings
  31.  
  32. (define (size-fg fg)
  33.   (let ((fgt (fg-type fg))
  34.         (vars (fg-vars fg)))
  35.     (iterate loop ((ops (fg-type-ops fgt))
  36.                    (size 0))
  37.       (cond ((null? ops) size)
  38.             (else
  39.              (xselect (car ops)
  40.                ((wop/fix)
  41.                 (destructure (((#f sign width vop voc1 . ops) ops))
  42.                   (loop ops (fx+ size width))))
  43.                ((wop/@fix)
  44.                 (destructure (((#f sign width-i vop voc1 . ops) ops))
  45.                   (loop ops (fx+ size (vref vars width-i)))))
  46.                ((wop/proc)
  47.                 (destructure (((#f sign cw-i proc-i vop voc1 . ops) ops))
  48.                   (loop ops (fx+ size (vref vars cw-i)))))
  49.                ((wop/var)
  50.                 (destructure (((#f sign cw-i opt-i vop voc1 . ops) ops))
  51.                   (loop ops (fx+ size (vref vars cw-i)))))
  52.                ((wop/depending-on)
  53.                 (destructure (((#f sdf#-i sdf-i mark-i fge-i . ops) ops))
  54.                   (let ((sdf (vref vars sdf-i)))
  55.                     (loop ops (fx+ size (sdf-width sdf))) )))
  56.                ((wop/subfield-ic)
  57.                 (destructure (((#f sf-i vop voc1 . ops) ops))
  58.                   (loop ops (fx+ size (size-fg (vref vars sf-i))))))
  59.                ((wop/mark)
  60.                 (destructure (((#f marker-i . ops) ops))
  61.                   (loop ops size)))
  62.                ))))))
  63.                           
  64.  
  65. ;;; Generate an assembly listing, given an ib vector, and optional bits.
  66.  
  67. (define (quicklist . args)
  68.   (destructure (((ibv bits) args))
  69.     (print-listing (terminal-output) 
  70.                    (if ibv ibv *current-ib-vector*)
  71.                    0 
  72.                    (and bits (bits-bv bits)))))
  73.  
  74. (define (listing . args)
  75.   (destructure (((ibv bits) args))
  76.     (print-listing (terminal-output) 
  77.                    (if ibv ibv *current-ib-vector*)
  78.                    0 
  79.                    (if bits (bits-bv bits) (bits-bv *current-bits*)))))
  80.  
  81.  
  82. (define (write-listing-to-file filespec)
  83.     (with-open-streams ((listing-stream (open (->filename filespec) '(out))))
  84.         (print-listing listing-stream 
  85.                        *current-ib-vector* 
  86.                        0 
  87.                        (bits-bv *current-bits*))))
  88.                                            
  89. ;;; Start address in bits.
  90.  
  91. (define (print-listing port ibv start-addr bytev)
  92.   (let ((offset start-addr)
  93.         (len (vector-length ibv)))
  94.     (iterate loop ((i 0) (names->hashes '()))
  95.         (cond ((fx>= i len)
  96.                (format port "~&~% label -> hash: ~s~%" names->hashes)
  97.                *repl-wont-print*)
  98.               (else 
  99.                (let ((ib (vref ibv i)))
  100.                  (list-ib port ib offset bytev)
  101.                  (loop (fx+ i 1)
  102.                        (cond ((empty? (ib-name ib)) names->hashes)
  103.                              (else `((,(ib-name ib) 
  104.                                       (,(if (ib-data-label? ib) 'd 'l)
  105.                                        ,(object-hash ib)))
  106.                                       ,@names->hashes))))))))
  107.     ))
  108.  
  109. ;;; Basically, just loop through instructions, and display each fg.
  110. ;;; For each element of instruction list, check to see if there is a comment
  111. ;;; to be printed after the fg.  If BYTEV is not null, then print the
  112. ;;; actual instruction bytes in the listing.
  113.  
  114. (lset *list-instruction-bytes* 6)
  115.  
  116. (define (list-ib port ib offset bytev) 
  117.   (let ((is (ib-instructions ib)))
  118.     (receive (label-tab instruction-tab min-cc)
  119.              (cond (bytev (return "~21t" "~28t" 48))
  120.                    (else  (return "~7t"  "~14t" 34)))
  121.       (cond ((null? is)
  122.              (format port "~&~k~g:~%" label-tab ib))
  123.             (else
  124.              (iterate loop ((addr  (fixnum-ashr (ib-address ib) 3))
  125.                             (label ib)
  126.                             (is    is)
  127.                             (cs    (list-cs port (ib-comments ib) '() min-cc)))
  128.                (cond ((null? is) *repl-wont-print*)
  129.                      (else
  130.                        (let* ((fg (car is))
  131.                               (size (fixnum-ashr (size-fg fg) 3)))
  132.                          (format port "~&~-5x  " (fx+ addr offset))
  133.                          (if bytev
  134.                              (display-bytev-slice port bytev addr (min 6 size)))
  135.                          (if label (format port "~k~g:" label-tab label))
  136.                          (format port "~k~g " instruction-tab fg)
  137.                          (let ((new-cs (list-cs port cs is min-cc)))
  138.                            (if (and bytev 
  139.                                     (fx> *list-instruction-bytes* 6)
  140.                                     (fx> size 6))
  141.                                (list-extra-bytes port bytev addr size 6))
  142.                            (loop (fx+ size addr) nil (cdr is) new-cs)))))
  143.                 ))))))
  144.  
  145. ;;; List comments.
  146.  
  147. ;;; Hack-o, returns a possibly cdr'd list of comments -- this is an
  148. ;;; efficiency hack.
  149.  
  150. (define (list-cs port cs is min-cc)
  151.    (cond (cs
  152.           (cond ((assq is cs)
  153.                  => (lambda (spec) 
  154.                       (list-comments port (cdr spec) min-cc)
  155.                       (cond ((null? (caar cs)) (cdr cs))
  156.                             ((eq? (car cs) spec) (cdr cs))
  157.                             (else cs))))
  158.                 (else cs)))
  159.          (else nil)))
  160.  
  161. (lset *as-list-comments?* t)
  162.                 
  163. (define (list-comments port comments minimum-comment-column)
  164.    (cond (*as-list-comments?*
  165.           (let ((c-pos (fixnum-maximum (fixnum-ceiling (hpos port) 8)
  166.                                        minimum-comment-column)))
  167.             (walk-backwards (lambda (c)
  168.                               (set (hpos port) c-pos)
  169.                               (cond ((string? c)
  170.                                      (format port "~a" c))
  171.                                     ((procedure? c)
  172.                                      (c port))
  173.                                     (else
  174.                                      (format port "bad comment: ~s" c))))
  175.                            comments)))))
  176.  
  177. ;;; Display the given number of bytev from a bytev.
  178.  
  179. (define (display-bytev-slice port bytev start run)
  180.   (let* ((blen (bytev-length bytev))
  181.          (given-end (fx+ start run))
  182.          (end (if (fx> given-end blen) blen given-end)))
  183.     (do ((i start (+ i 1)))
  184.         ((fx>= i end) 'done)
  185.       (let ((byte (bref bytev i)))
  186.         (writec port (digit->char (fixnum-ashr byte 4.) 16.))
  187.         (writec port (digit->char (fixnum-logand byte 15.) 16.))
  188.         ))))
  189.  
  190. ;;; 
  191.  
  192. (define (list-extra-bytes port bytev start length runsize)
  193.   (let ((length (fx- (min length *list-instruction-bytes*) runsize))
  194.         (start (fx+ start runsize)))
  195.     (iterate loop ((start start) (length length))
  196.         (cond ((fx< length 1) 'done)
  197.               (else
  198.                (format port "~&       ")
  199.                (display-bytev-slice port bytev start (min length runsize))
  200.                (loop (fx+ start runsize) (fx- length runsize)))))))
  201.